home *** CD-ROM | disk | FTP | other *** search
/ The Atari Compendium / The Atari Compendium (Toad Computers) (1994).iso / files / prgtools / langs / clisp-c.zoo / defs1.lsp < prev    next >
Encoding:
Text File  |  1993-06-05  |  27.1 KB  |  683 lines
  1. ;;;; Einige Definitionen von Standard-Funktionen in LISP
  2. ;;;; 1.8.1989, 2.9.1989, 8.10.1989
  3.  
  4. (in-package "LISP")
  5. (export '(doseq dohash #-UNIX *default-time-zone* default-directory dir))
  6. (in-package "SYSTEM")
  7.  
  8.  
  9. ;;; Funktionen für Symbole (Kapitel 10)
  10.  
  11. (defun copy-symbol (symbol &optional flag)
  12.                    ;; Common LISP, S. 169
  13.   (let ((sym (make-symbol (symbol-name symbol))))
  14.     (when flag
  15.       (when (boundp symbol) (set sym (symbol-value symbol)))
  16.       (when (fboundp symbol) (sys::%putd sym (symbol-function symbol)))
  17.       (sys::%putplist sym (copy-list (symbol-plist symbol)))
  18.     )
  19.     sym
  20. ) )
  21.  
  22. (let ((gentemp-count 0))
  23.   (defun gentemp (&optional (prefix "T") (package *package*))
  24.                  ;; Common LISP, S. 170
  25.     (loop
  26.       (setq gentemp-count (1+ gentemp-count))
  27.       (multiple-value-bind (sym flag)
  28.         (intern
  29.           (string-concat prefix
  30.             (write-to-string gentemp-count :base 10 :radix nil)
  31.           )
  32.           package
  33.         )
  34.         (unless flag (return sym))
  35. ) ) ) )
  36.  
  37.  
  38. ;;; Macros für Packages (Kapitel 11), S. 187-188
  39.  
  40. (defmacro do-symbols ((var &optional (packageform '*package*) (resultform nil))
  41.                       &body body &environment env)
  42.   (multiple-value-bind (body-rest declarations) (system::parse-body body nil env)
  43.     (setq declarations (if declarations `((DECLARE ,@declarations)) '()))
  44.     (let ((packvar (gensym)))
  45.       `(BLOCK NIL
  46.          (LET ((,packvar ,packageform))
  47.            (LET ((,var NIL))
  48.              ,@declarations
  49.              ,var ; var wird nur zum Schein ausgewertet
  50.              (SYSTEM::MAP-SYMBOLS #'(LAMBDA (,var) ,@declarations ,@body-rest) ,packvar)
  51.              ,resultform
  52.        ) ) )
  53. ) ) )
  54.  
  55. (defmacro do-external-symbols ((var &optional (packageform '*package*) (resultform nil))
  56.                                &body body &environment env)
  57.   (multiple-value-bind (body-rest declarations) (system::parse-body body nil env)
  58.     (setq declarations (if declarations `((DECLARE ,@declarations)) '()))
  59.     (let ((packvar (gensym)))
  60.       `(BLOCK NIL
  61.          (LET ((,packvar ,packageform))
  62.            (LET ((,var NIL))
  63.              ,@declarations
  64.              ,var ; var wird nur zum Schein ausgewertet
  65.              (SYSTEM::MAP-EXTERNAL-SYMBOLS #'(LAMBDA (,var) ,@declarations ,@body-rest) ,packvar)
  66.              ,resultform
  67.        ) ) )
  68. ) ) )
  69.  
  70. (defmacro do-all-symbols ((var &optional (resultform nil))
  71.                           &body body &environment env)
  72.   (multiple-value-bind (body-rest declarations) (system::parse-body body nil env)
  73.     (setq declarations (if declarations `((DECLARE ,@declarations)) '()))
  74.     `(BLOCK NIL
  75.        (LET ((,var NIL))
  76.          ,@declarations
  77.          ,var ; var wird nur zum Schein ausgewertet
  78.          (SYSTEM::MAP-ALL-SYMBOLS #'(LAMBDA (,var) ,@declarations ,@body-rest))
  79.          ,resultform
  80.      ) )
  81. ) )
  82.  
  83. ;;; Modulverwaltung (Kapitel 11.8), CLTL S. 188
  84.  
  85. (defvar *modules* nil)
  86.  
  87. (defun provide (module-name)
  88.   (setq *modules* (adjoin (string module-name) *modules* :test #'string=))
  89. )
  90.  
  91. (defun require (module-name &optional (pathname nil p-given))
  92.   (unless (member (string module-name) *modules* :test #'string-equal)
  93.     (unless p-given (setq pathname (pathname module-name)))
  94.     (let (#-CLISP(*default-pathname-defaults* '#""))
  95.       (if (atom pathname) (load pathname) (mapcar #'load pathname))
  96.     )
  97. ) )
  98.  
  99.  
  100. ;;; Konstanten für Zahlen (Kapitel 12)
  101.  
  102. ; vgl. File INTLOG.TXT
  103. (defconstant boole-clr 0)
  104. (defconstant boole-set 15)
  105. (defconstant boole-1 10)
  106. (defconstant boole-2 12)
  107. (defconstant boole-c1 5)
  108. (defconstant boole-c2 3)
  109. (defconstant boole-and 8)
  110. (defconstant boole-ior 14)
  111. (defconstant boole-xor 6)
  112. (defconstant boole-eqv 9)
  113. (defconstant boole-nand 7)
  114. (defconstant boole-nor 1)
  115. (defconstant boole-andc1 4)
  116. (defconstant boole-andc2 2)
  117. (defconstant boole-orc1 13)
  118. (defconstant boole-orc2 11)
  119.  
  120. ; Zum Wiedereinlesen von BYTEs:
  121. (defun make-byte (&key size position) (byte size position))
  122.  
  123.  
  124. ;;; Konstanten für Zeichen (Kapitel 13)
  125.  
  126. (defconstant char-code-limit 256)
  127. (defconstant char-font-limit 16)
  128. (defconstant char-bits-limit 16)
  129.                    ;; Common LISP, S. 233, 234
  130.  
  131. (defconstant char-control-bit 1)
  132. (defconstant char-meta-bit 2)
  133. (defconstant char-super-bit 4)
  134. (defconstant char-hyper-bit 8)
  135.                    ;; Common LISP, S. 243
  136.  
  137.  
  138. ;;; Funktionen für Sequences (Kapitel 14)
  139.  
  140. (defmacro doseq ((var seqform &optional resultform) &body body &environment env)
  141.   (multiple-value-bind (body-rest declarations) (system::parse-body body nil env)
  142.     (setq declarations (if declarations `((DECLARE ,@declarations)) '()))
  143.     (let ((seqvar (gensym)))
  144.       `(BLOCK NIL
  145.          (LET ((,seqvar ,seqform))
  146.            (LET ((,var NIL))
  147.              ,@declarations
  148.              ,var ; var wird nur zum Schein ausgewertet
  149.              (MAP NIL
  150.                   #'(LAMBDA (,var) ,@declarations (TAGBODY ,@body-rest))
  151.                   ,seqvar
  152.              )
  153.              ,resultform
  154.        ) ) )
  155. ) ) )
  156.  
  157.  
  158. ;;; Funktionen für Listen (Kapitel 15)
  159.  
  160. ; Hilfsversion von MEMBER, die das :KEY-Argument auch auf item anwendet:
  161. (defun sys::member1 (item list &rest rest &key test test-not key)
  162.   (declare (ignore test test-not))
  163.   (unless key (setq key #'identity))
  164.   (apply #'member (funcall key item) list rest)
  165. )
  166.  
  167. (defun union (list1 list2 &rest rest &key test test-not key)
  168.   (declare (ignore test test-not key))
  169.   (cond ((endp list1) list2)
  170.         ((apply #'sys::member1 (car list1) list2 rest)
  171.          (apply #'union (cdr list1) list2 rest))
  172.         (t (cons (car list1) (apply #'union (cdr list1) list2 rest)))
  173. ) )
  174.  
  175. (defun nunion (list1 list2 &rest rest &key test test-not key)
  176.   (declare (ignore test test-not key))
  177.   (cond ((endp list1) list2)
  178.         ((apply #'sys::member1 (car list1) list2 rest)
  179.          (apply #'nunion (cdr list1) list2 rest))
  180.         (t (rplacd list1 (apply #'nunion (cdr list1) list2 rest)))
  181. ) )
  182.  
  183. (defun intersection (list1 list2 &rest rest &key test test-not key)
  184.   (declare (ignore test test-not key))
  185.   (cond ((endp list1) nil)
  186.         ((apply #'sys::member1 (car list1) list2 rest)
  187.          (cons (car list1)
  188.                (apply #'intersection (cdr list1) list2 rest)))
  189.         (t (apply #'intersection (cdr list1) list2 rest))
  190. ) )
  191.  
  192. (defun nintersection (list1 list2 &rest rest &key test test-not key)
  193.   (declare (ignore test test-not key))
  194.   (cond ((endp list1) nil)
  195.         ((apply #'sys::member1 (car list1) list2 rest)
  196.          (rplacd list1 (apply #'nintersection (cdr list1) list2 rest)) )
  197.         (t (apply #'nintersection (cdr list1) list2 rest))
  198. ) )
  199.  
  200. (defun set-difference (list1 list2 &rest rest &key test test-not key)
  201.   (declare (ignore test test-not key))
  202.   (cond ((endp list1) nil)
  203.         ((not (apply #'sys::member1 (car list1) list2 rest))
  204.          (cons (car list1)
  205.                (apply #'set-difference (cdr list1) list2 rest)
  206.         ))
  207.         (t (apply #'set-difference (cdr list1) list2 rest))
  208. ) )
  209.  
  210. (defun nset-difference (list1 list2 &rest rest &key test test-not key)
  211.   (declare (ignore test test-not key))
  212.   (cond ((endp list1) nil)
  213.         ((not (apply #'sys::member1 (car list1) list2 rest))
  214.          (rplacd list1 (apply #'nset-difference (cdr list1) list2 rest)) )
  215.         (t (apply #'nset-difference (cdr list1) list2 rest))
  216. ) )
  217.  
  218. (defun set-exclusive-or (list1 list2 &rest rest &key test test-not key)
  219.   (declare (ignore test test-not key))
  220.   (append (apply #'set-difference list1 list2 rest)
  221.           (apply #'set-difference list2 list1 rest)
  222. ) )
  223.  
  224. (defun nset-exclusive-or (list1 list2 &rest rest &key test test-not key)
  225.   (declare (ignore test test-not key))
  226.   (nconc (apply #'set-difference list1 list2 rest)
  227.          (apply #'nset-difference list2 list1 rest)
  228. ) )
  229.  
  230. (defun subsetp (list1 list2 &rest rest &key test test-not key)
  231.   (declare (ignore test test-not key))
  232.   (do ((l list1 (cdr l)))
  233.       ((endp l) t)
  234.     (if (not (apply #'sys::member1 (car l) list2 rest)) (return nil))
  235. ) )
  236.  
  237.  
  238. ;;; Funktionen für Hash-Tabellen (Kapitel 16)
  239.  
  240. (defmacro dohash ((keyvar valuevar HTform &optional resultform) &body body &environment env)
  241.   (multiple-value-bind (body-rest declarations) (system::parse-body body nil env)
  242.     (setq declarations (if declarations `((DECLARE ,@declarations)) '()))
  243.     (let ((HTvar (gensym)))
  244.       `(BLOCK NIL
  245.          (LET ((,HTvar ,HTform))
  246.            (LET ((,keyvar NIL) (,valuevar NIL))
  247.              ,@declarations
  248.              ,keyvar ,valuevar ; werden nur zum Schein ausgewertet
  249.              (MAPHASH
  250.                #'(LAMBDA (,keyvar ,valuevar) ,@declarations (TAGBODY ,@body-rest))
  251.                ,HTvar
  252.              )
  253.              ,resultform
  254.        ) ) )
  255. ) ) )
  256.  
  257.  
  258. ;;; Funktionen für Strings (Kapitel 18)
  259.  
  260. (defun string-trim (character-bag string)
  261.   (sys::string-both-trim character-bag character-bag string)
  262. )
  263.  
  264. (defun string-left-trim (character-bag string)
  265.   (sys::string-both-trim character-bag nil string)
  266. )
  267.  
  268. (defun string-right-trim (character-bag string)
  269.   (sys::string-both-trim nil character-bag string)
  270. )
  271.  
  272.  
  273. ;;; Funktionen für Zeit (Kapitel 25.4.1)
  274.  
  275. #+CLISP1 (defconstant internal-time-units-per-second 200)
  276.  
  277. ; Hilfsfunktion für Macro TIME
  278. (defun %time (new-real1 new-real2 new-run1 new-run2 new-gc1 new-gc2
  279.               new-space1 new-space2 new-gccount
  280.               old-real1 old-real2 old-run1 old-run2 old-gc1 old-gc2
  281.               old-space1 old-space2 old-gccount)
  282.   (macrolet ((merge-2-values (val1 val2)
  283.                #+(or ATARI AMIGA DOS OS/2 VMS) `(dpb ,val1 (byte 16 16) ,val2)
  284.                #+UNIX `(+ (* ,val1 internal-time-units-per-second) ,val2)
  285.             ))
  286.     (let ((Real-Time (- (merge-2-values new-real1 new-real2)
  287.                         (merge-2-values old-real1 old-real2)
  288.           )          )
  289.           (Run-Time (- (merge-2-values new-run1 new-run2)
  290.                        (merge-2-values old-run1 old-run2)
  291.           )         )
  292.           (GC-Time (- (merge-2-values new-gc1 new-gc2)
  293.                       (merge-2-values old-gc1 old-gc2)
  294.           )        )
  295.           (Space (- (dpb new-space1 (byte 24 24) new-space2)
  296.                     (dpb old-space1 (byte 24 24) old-space2)
  297.           )      )
  298.           (GC-Count (- new-gccount old-gccount))
  299.          )
  300.       (terpri)
  301.       (write-string "Real time: ")
  302.       (write (float (/ Real-Time internal-time-units-per-second)))
  303.       (write-string " sec.")
  304.       (terpri)
  305.       (write-string "Run time: ")
  306.       (write (float (/ Run-Time internal-time-units-per-second)))
  307.       (write-string " sec.")
  308.       (terpri)
  309.       (write-string "Space: ") (write Space) (write-string " Bytes")
  310.       (when (or (plusp GC-Count) (plusp GC-Time))
  311.         (terpri)
  312.         (write-string "GC: ") (write GC-Count)
  313.         (write-string ", GC time: ")
  314.         (write (float (/ GC-Time internal-time-units-per-second)))
  315.         (write-string " sec.")
  316.       )
  317. ) ) )
  318.  
  319. ; (sleep seconds) macht seconds Sekunden Pause. CLTL S. 447
  320. (defun sleep (time)
  321.   (if (and (numberp time) (not (complexp time)) (not (minusp time)))
  322.     (progn
  323.       #+(or ATARI AMIGA DOS OS/2 VMS)
  324.       (if (> time '#,(floor (expt 2 31) internal-time-units-per-second))
  325.         ; Mehr als 248 bzw. 994 bzw. 497 Tage? (Denn sys::%sleep akzeptiert nur
  326.         ; Argumente < 2^32, bei #+(or DOS OS/2 VMS) sogar nur Argumente < 2^31.)
  327.         (loop ; ja -> Endlosschleife
  328.           #+(or AMIGA OS/2 VMS)
  329.           (sys::%sleep '#,(* 86400 internal-time-units-per-second))
  330.         )
  331.         (sys::%sleep (round (* time internal-time-units-per-second)))
  332.       )
  333.       #+UNIX
  334.       (if (> time 16700000) ; mehr als 193 Tage?
  335.         (loop (sys::%sleep 86400 0)) ; ja -> Endlosschleife
  336.         (multiple-value-bind (seconds rest) (floor time)
  337.           (sys::%sleep seconds (round (* rest internal-time-units-per-second)))
  338.       ) )
  339.     )
  340.     (error #+DEUTSCH "~S: Argument muß eine Zahl >=0 sein, nicht ~S"
  341.            #+ENGLISH "~S: argument ~S should be a nonnegative number"
  342.            #+FRANCAIS "~S : L'argument doit être un nombre positif ou zéro et non ~S"
  343.            'sleep time
  344. ) ) )
  345.  
  346.  
  347. ;; Funktionen für Zeit-Umrechnung und Zeitzonen (CLTL Kapitel 25.4.1)
  348. ;; Version 2, beinhaltet mehr Mathematik und basiert auf März-Jahren
  349.  
  350. ; Ein März-Jahr sei die Periode vom 1.3. bis 28/29.2.
  351. ; Vorteil: Umrechnung Monat/Tag <--> Jahrtag wird einfacher.
  352. ; Skizze:
  353. ;   1.1.1900            1.1.1901            1.1.1902
  354. ;   ⇩                   ⇩                   ⇩
  355. ;   |-------------------|-------------------|-------------------|
  356. ;   |     Jahr 1900     |     Jahr 1901     |     Jahr 1902     |
  357. ;   |--|----------------|--|----------------|--|----------------|--|
  358. ;      |  März-Jahr 1900   |  März-Jahr 1901   |  März-Jahr 1902   |
  359. ;      |-------------------|-------------------|-------------------|
  360. ;      ⇧                   ⇧                   ⇧
  361. ;      1.3.1900            1.3.1901            1.3.1902
  362.  
  363. ; (UTag Jahr) = Nummer des Tages 1.3.Jahr (gegenüber 1.1.1900)
  364. ; UTag(J) = 365*J + floor(J/4) - floor(J/100) + floor(J/400) - 693901
  365. ; damit  UTag(J) - UTag(J-1) = 365 + [1 falls J Schaltjahr]
  366. ; und    UTag(1899) = -306
  367. ; gelten.
  368. (defun UTag (Jahr)
  369.   (+ (* 365 Jahr) (floor Jahr 4) (- (floor Jahr 100)) (floor Jahr 400) -693901)
  370. )
  371.  
  372. ; Näherungwert:
  373. ; 365+1/4-1/100+1/400 = 365.2425 = 146097/400 .
  374. ; Durch Betrachtung einer Wertetabelle der 400-periodischen Funktion
  375. ; (J -> UTag(J)-146097/400*J) sieht man:
  376. ;   146097/400*J - 693902.4775 <= UTag(J) <= 146097/400*J - 693900.28
  377.  
  378. ; Bestimmt zu einem Tag (0 = 1.1.1900) das März-Jahr und den Tag im März-Jahr.
  379. ; (Jahr&Tag UTTag) ==> Jahr, Jahrtag
  380. ; mit (= UTTag (+ (UTag Jahr) Jahrtag))
  381. (defun Jahr&Tag (UTTag)
  382.   ; Gesucht ist das größte Jahr mit UTag(Jahr) <= UTTag.
  383.   ; Für dieses Jahr J gilt
  384.   ; 146097/400*J - 693902.4775 <= UTag(J) <= UTTag < UTag(J+1) <= 146097/400*J - 693535.0375,
  385.   ; also 146097*J - 277560991 <= 400*UTTag < 146097*J - 277414015,
  386.   ; also 146097*(J-1900) + 23309 <= 400*UTTag < 146097*(J-1900) + 170285,
  387.   ; also J + 0.159544... <= 1900 + UTTag/(146097/400) < J + 1.165561... .
  388.   (let* ((Jahr (+ 1900 (floor (- UTTag 58) 146097/400)))
  389.          (Jahresanfang (UTag Jahr)))
  390.     ; Wegen 146097*(J-1900) + 109 <= 400*(UTTag-58) < 146097*(J-1900) + 147084,
  391.     ; also J <= 1900 + (UTTag-58)/(146097/400) < J+1.006755...,
  392.     ; ist die Schätzung  Jahr := floor(1900 + (UTTag-58)/(146097/400))
  393.     ; meist richtig und jedenfalls nicht zu klein und um höchstens 1 zu groß.
  394.     (when (< UTTag Jahresanfang) ; zu groß?
  395.       (decf Jahr)
  396.       (setq Jahresanfang (UTag Jahr))
  397.     )
  398.     (values Jahr (- UTTag Jahresanfang))
  399. ) )
  400.  
  401. ; Die Grenzen der Sommerzeit:
  402. ; Es gibt folgende Typen der Sommerzeit-Berechnung:
  403. ;   0    DST_NONE: Daylight Savings Time not observed
  404. ;   1    DST_USA: United States DST
  405. ;   2    DST_AUST: Australian DST
  406. ;   3    DST_WET: Western European DST
  407. ;   4    DST_MET: Middle European DST
  408. ;   5    DST_EET: Eastern European DST
  409. ;   6    DST_CAN: Canadian DST
  410. ;   7    DST_GB: Great Britain and Eire DST
  411. ;   8    DST_RUM: Rumanian DST
  412. ;   9    DST_TUR: Turkish DST
  413. ;  10    DST_AUSTALT: Australian-style DST with shift in 1986
  414.  
  415. ; Stellt fest, ob bei gegebenem März-Jahr und Tag und Stunde Sommerzeit gilt.
  416. (defun NONE-Sommerzeit-p (Jahr Jahrtag Stunde)
  417.   (declare (ignore Jahr Jahrtag Stunde))
  418.   nil
  419. )
  420.  
  421. ; In Deutschland (in welchen Jahren ??)
  422. ; beginnt sie am letzten Märzsonntag, 2h MEZ nachts (inklusive)
  423. ; und endet am letzten Septembersonntag, 2h MEZ nachts (exklusive).
  424. #|
  425. ; (MET-Sommerzeit-Grenzen Jahr) liefert:
  426. ;       Märzjahresstunde des letzten Sonntags im März, 2h
  427. ; und   Märzjahresstunde des letzten Sonntags im September, 2h, minus 1.
  428. (defun MET-Sommerzeit-Grenzen (Jahr)
  429.   (let ((Jahresanfang (UTag Jahr)))
  430.     (flet ((letzter-Sonntag-vor (Tag) ; liefert den letzten Sonntag vorher (inklusive)
  431.              (- Tag (mod (- Tag 6) 7))
  432.           ))
  433.       (cons
  434.         (+ (* 24 (- (letzter-Sonntag-vor (+ Jahresanfang 30)) ; Sonntag vor 31. März
  435.                     Jahresanfang
  436.            )     )
  437.            2
  438.         )
  439.         (1-
  440.           (+ (* 24 (- (letzter-Sonntag-vor (+ Jahresanfang 213)) ; Sonntag vor 30. September
  441.                       Jahresanfang
  442.              )     )
  443.              2
  444.       ) ) )
  445. ) ) )
  446. |#
  447.  
  448. ; Stellt fest, ob bei gegebenem März-Jahr und Tag und Stunde (MEZ)
  449. ; in der Bundesrepublik Deutschland Sommerzeit gilt.
  450. (defun MET-Sommerzeit-p (Jahr Jahrtag Stunde)
  451.   (and (<= 1980 Jahr 2000)
  452.     (let ((Jahresstunde (+ (* 24 Jahrtag) Stunde))
  453.           (Grenzen
  454.             (svref '#( ; Sommerzeit-Intervalle (vorausberechnet)
  455.                        ;; War in den 30er/40er Jahren schon Sommerzeit??
  456.                      ; (674 . 5041) ; 1970 : 29.3. 2h bis 27.9. 2h
  457.                      ; (650 . 5017) ; 1971 : 28.3. 2h bis 26.9. 2h
  458.                      ; (602 . 4969) ; 1972 : 26.3. 2h bis 24.9. 2h
  459.                      ; (578 . 5113) ; 1973 : 25.3. 2h bis 30.9. 2h
  460.                      ; (722 . 5089) ; 1974 : 31.3. 2h bis 29.9. 2h
  461.                      ; (698 . 5065) ; 1975 : 30.3. 2h bis 28.9. 2h
  462.                      ; (650 . 5017) ; 1976 : 28.3. 2h bis 26.9. 2h
  463.                      ; (626 . 4993) ; 1977 : 27.3. 2h bis 25.9. 2h
  464.                      ; (602 . 4969) ; 1978 : 26.3. 2h bis 24.9. 2h
  465.                      ; (578 . 5113) ; 1979 : 25.3. 2h bis 30.9. 2h
  466.                      ; In Deutscland wurde die Sommerzeit 1980 eingeführt.
  467.                        (698 . 5065) ; 1980 : 30.3. 2h bis 28.9. 2h
  468.                        (674 . 5041) ; 1981 : 29.3. 2h bis 27.9. 2h
  469.                        (650 . 5017) ; 1982 : 28.3. 2h bis 26.9. 2h
  470.                        (626 . 4993) ; 1983 : 27.3. 2h bis 25.9. 2h
  471.                        (578 . 5113) ; 1984 : 25.3. 2h bis 30.9. 2h
  472.                        (722 . 5089) ; 1985 : 31.3. 2h bis 29.9. 2h
  473.                        (698 . 5065) ; 1986 : 30.3. 2h bis 28.9. 2h
  474.                        (674 . 5041) ; 1987 : 29.3. 2h bis 27.9. 2h
  475.                        (626 . 4993) ; 1988 : 27.3. 2h bis 25.9. 2h
  476.                        (602 . 4969) ; 1989 : 26.3. 2h bis 24.9. 2h
  477.                        (578 . 5113) ; 1990 : 25.3. 2h bis 30.9. 2h
  478.                        (722 . 5089) ; 1991 : 31.3. 2h bis 29.9. 2h
  479.                        (674 . 5041) ; 1992 : 29.3. 2h bis 27.9. 2h
  480.                        (650 . 5017) ; 1993 : 28.3. 2h bis 26.9. 2h
  481.                        (626 . 4993) ; 1994 : 27.3. 2h bis 25.9. 2h
  482.                        (602 . 4969) ; 1995 : 26.3. 2h bis 24.9. 2h
  483.                        (722 . 5089) ; 1996 : 31.3. 2h bis 29.9. 2h
  484.                        (698 . 5065) ; 1997 : 30.3. 2h bis 28.9. 2h
  485.                        (674 . 5041) ; 1998 : 29.3. 2h bis 27.9. 2h
  486.                        (650 . 5017) ; 1999 : 28.3. 2h bis 26.9. 2h
  487.                        (602 . 4969) ; 2000 : 26.3. 2h bis 24.9. 2h
  488.                      )
  489.                    (- Jahr 1980)
  490.          )) )
  491.       (<= (car Grenzen) Jahresstunde (cdr Grenzen))
  492. ) ) )
  493.  
  494. #-UNIX
  495. (defvar *default-time-zone* -1) ; 1 h östlich GMT = MEZ
  496. ; NB: Zeitzone muß nicht ganzzahlig sein, sollte aber Vielfaches
  497. ; einer Sekunde sein.
  498. #-UNIX
  499. (defvar *default-dst-check* #'MET-Sommerzeit-p) ; MEZ-Sommerzeit
  500.  
  501. ; andere Abbildung  Jahrtag -> Monat  für decode-universal-time:
  502. ; Seien Monat und Jahrtag auf den 1. März bezogen
  503. ; (d.h. Jahrtag = 0 am 1. März, = 364 am 28. Februar, usw.,
  504. ;  und März=0,...,Dezember=9,Januar=10,Februar=11).
  505. ; Dann ist
  506. ;                Monat = floor(a*Jahrtag+b)
  507. ; sofern a und b so gewählt sind, daß die Ungleichungen
  508. ;   122*a+b >= 4, 275*a+b >= 9, 30*a+b < 1, 336*a+b < 11
  509. ; gelten. Dies ist ein Viereck im Bereich
  510. ; 0.032653... = 8/245 <= a <= 7/214 = 0.032710...,
  511. ; 0.009345... = 1/107 <= b <= 1/49 = 0.020408...,
  512. ; in dem z.B. der Punkt (a=5/153,b=2/153) liegt:
  513. ;                Monat = floor((5*Jahrtag+2)/153).
  514.  
  515. ; andere Abbildung  Monat -> Jahrtag
  516. ; für encode-universal-time und decode-universal-time:
  517. ; Seien Monat und Jahrtag auf den 1. März bezogen
  518. ; (d.h. Jahrtag = 0 am 1. März, = 364 am 28. Februar, usw.,
  519. ;  und März=0,...,Dezember=9,Januar=10,Februar=11).
  520. ; Die Abbildung
  521. ;      Monat   0  1  2  3  4   5   6   7   8   9   10  11
  522. ;      Jahrtag 0 31 61 92 122 153 184 214 245 275 306 337
  523. ; kann man schreiben
  524. ;                Jahrtag = floor(a*Monat+b)
  525. ; sofern a und b so gewählt sind, daß die Ungleichungen
  526. ;   a+b >= 31, 11*a+b >= 337, 4*a+b < 123, 9*a+b < 276
  527. ; gelten. Dies ist ein Viereck im Bereich
  528. ; 30.5714... = 214/7 <= a <= 245/8 = 30.625,
  529. ; 0.375      = 3/8   <= b <= 5/7   = 0.7142...,
  530. ; in dem z.B. der Punkt (a=153/5,b=2/5) liegt:
  531. ;                Jahrtag = floor((153*Monat+2)/5).
  532. ; Dies ist allerdings langsamer als ein Tabellenzugriff.
  533.  
  534. (macrolet ((Monat->Jahrtag (Monat) ; 0 <= Monat < 12, 0=März,...,11=Februar
  535.              `(svref '#(0 31 61 92 122 153 184 214 245 275 306 337) ,Monat)
  536.           ))
  537.  
  538. ; (encode-universal-time second minute hour date month year [time-zone]),
  539. ; CLTL S. 446
  540. (defun encode-universal-time
  541.               (Sekunde Minute Stunde Tag Monat Jahr &optional (Zeitzone nil)
  542.                &aux Monat3 Jahr3 Jahrtag UTTag)
  543.   (unless (and (and (integerp Jahr)
  544.                     (progn
  545.                       (when (<= 0 Jahr 99)
  546.                         (multiple-value-bind (i1 i2 i3 i4 i5 Jahrjetzt) (get-decoded-time)
  547.                           (declare (ignore i1 i2 i3 i4 i5))
  548.                           (setq Jahr
  549.                             (+ Jahr (* 100 (ceiling (- Jahrjetzt Jahr 50) 100)))
  550.                       ) ) )
  551.                       (<= 1900 Jahr)
  552.                )    )
  553.                (and (integerp Monat) (<= 1 Monat 12))
  554.                (progn
  555.                  (if (< Monat 3)
  556.                    (setq Jahr3 (1- Jahr)  Monat3 (+ Monat 9)) ; Monat3 10..11
  557.                    (setq Jahr3 Jahr       Monat3 (- Monat 3)) ; Monat3 0..9
  558.                  )
  559.                  (and (and (integerp Tag) (<= 1 Tag))
  560.                       (progn
  561.                         (setq Jahrtag (+ (1- Tag) (Monat->Jahrtag Monat3)))
  562.                         (setq UTTag (+ Jahrtag (UTag Jahr3)))
  563.                         (and (if (not (eql Monat3 11))
  564.                                (< Jahrtag (Monat->Jahrtag (1+ Monat3)))
  565.                                (< UTTag (UTag (1+ Jahr3)))
  566.                              )
  567.                              (and (integerp Stunde) (<= 0 Stunde 23))
  568.                              (and (integerp Minute) (<= 0 Minute 59))
  569.                              (and (integerp Sekunde) (<= 0 Sekunde 59))
  570.                              (and (progn
  571.                                     (unless Zeitzone
  572.                                       (setq Zeitzone
  573.                                         #-UNIX (- *default-time-zone*
  574.                                                   (if (funcall *default-dst-check* Jahr3 Jahrtag Stunde) 1 0)
  575.                                                )
  576.                                         #+UNIX (default-time-zone)
  577.                                     ) )
  578.                                     (when (floatp Zeitzone) (setq Zeitzone (rational Zeitzone)))
  579.                                     (or (integerp Zeitzone)
  580.                                         (and (rationalp Zeitzone) (integerp (* 3600 Zeitzone)))
  581.                                   ) )
  582.                                   (<= -12 Zeitzone 12)
  583.           )    ) )    ) )    )
  584.     (error #+DEUTSCH "Inkorrektes Datum: ~S.~S.~S, ~Sh~Sm~Ss, Zeitzone ~S"
  585.            #+ENGLISH "incorrect date: ~S.~S.~S, ~Sh~Sm~Ss, time zone ~S"
  586.            #+FRANCAIS "Date incorrecte : ~S/~S/~S, ~Sh~Sm~Ss, heure ~S"
  587.            Tag Monat Jahr Stunde Minute Sekunde Zeitzone
  588.   ) )
  589.   (+ Sekunde
  590.      (* 60 (+ Minute
  591.               (* 60 (+ Stunde Zeitzone
  592.                        (* 24 UTTag)
  593.   )  )     )  )     )
  594. )
  595.  
  596. ; (decode-universal-time universal-time [time-zone]), CLTL S. 445
  597. (defun decode-universal-time (UT &optional (time-zone nil)
  598.                               &aux Sommerzeit Zeitzone)
  599.   (if time-zone
  600.     (setq Sommerzeit nil Zeitzone time-zone)
  601.     #-UNIX
  602.     (setq time-zone *default-time-zone*
  603.           Sommerzeit (let ((UT (- UT (round (* 3600 time-zone)))))
  604.                        (multiple-value-bind (UTTag Stunde) (floor (floor UT 3600) 24)
  605.                          (multiple-value-bind (Jahr Jahrtag) (Jahr&Tag UTTag)
  606.                            (funcall *default-dst-check* Jahr Jahrtag Stunde)
  607.                      ) ) )
  608.           Zeitzone (- time-zone (if Sommerzeit 1 0))
  609.     )
  610.     #+UNIX
  611.     (setq time-zone (default-time-zone) Sommerzeit nil Zeitzone time-zone)
  612.   )
  613.   ; time-zone = Zeitzone ohne Sommerzeitberücksichtigung,
  614.   ; Zeitzone = Zeitzone mit Sommerzeitberücksichtigung.
  615.   (let ((UTSekunden (- UT (round (* 3600 Zeitzone)))))
  616.     (multiple-value-bind (UTMinuten Sekunde) (floor UTSekunden 60)
  617.       (multiple-value-bind (UTStunden Minute) (floor UTMinuten 60)
  618.         (multiple-value-bind (UTTage Stunde) (floor UTStunden 24)
  619.           (multiple-value-bind (Jahr Jahrtag) (Jahr&Tag UTTage)
  620.             (let* ((Monat (floor (+ (* 5 Jahrtag) 2) 153))
  621.                    (Tag (1+ (- Jahrtag (Monat->Jahrtag Monat)))))
  622.               (if (< Monat 10) ; Monat März..Dezember?
  623.                 (setq Monat (+ Monat 3)) ; Monat 3..12
  624.                 (setq Monat (- Monat 9) Jahr (+ Jahr 1)) ; Monat 1..2
  625.               )
  626.               (values Sekunde Minute Stunde Tag Monat Jahr (mod UTTage 7)
  627.                       Sommerzeit time-zone
  628. ) ) ) ) ) ) ) )
  629.  
  630. ) ; Ende von macrolet
  631.  
  632. ; (get-decoded-time), CLTL S. 445
  633. (defun get-decoded-time ()
  634.   (decode-universal-time (get-universal-time))
  635. )
  636.  
  637.  
  638. ;;; Verschiedenes
  639.  
  640. ; (concat-pnames obj1 obj2) liefert zu zwei Objekten (Symbolen oder Strings)
  641. ;  ein Symbol, dessen Printname sich aus den beiden Objekten zusammensetzt.
  642. (defun concat-pnames (obj1 obj2)
  643.   (let ((str (string-concat (string obj1) (string obj2))))
  644.     (if (and (plusp (length str)) (eql (char str 0) #\:))
  645.       (intern (subseq str 1) *keyword-package*)
  646.       (intern str)
  647. ) ) )
  648.  
  649. ; (default-directory) ist ein Synonym für (cd).
  650. (defun default-directory () (cd))
  651.  
  652. ; FORMAT-Control-String zur Datumsausgabe,
  653. ; anwendbar auf eine Liste (sec min hour day month year ...),
  654. ; belegt 17-19 Zeichen
  655. (defconstant *date-format*
  656.   #+DEUTSCH "~1{~3@*~D.~4@*~D.~5@*~D ~2@*~2,'0D:~1@*~2,'0D:~0@*~2,'0D~:}"
  657.   #+ENGLISH "~1{~5@*~D/~4@*~D/~3@*~D ~2@*~2,'0D.~1@*~2,'0D.~0@*~2,'0D~:}"
  658.   #+FRANCAIS "~1{~3@*~D/~4@*~D/~5@*~D ~2@*~2,'0D:~1@*~2,'0D:~0@*~2,'0D~:}"
  659. )
  660.  
  661. ; zeigt ein Directory an.
  662. (defun dir (&optional (pathnames #+(or ATARI DOS) '("*.*\\" "*.*")
  663.                                  #+(or AMIGA UNIX OS/2) '("*/" "*")
  664.                                  #+VMS '("[.*]" "*.*")
  665.            )          )
  666.   (flet ((onedir (pathname)
  667.            (let ((pathname-list (directory pathname :full t)))
  668.              (if (every #'atom pathname-list)
  669.                (format t "~{~%~A~}"
  670.                  (sort pathname-list #'string< :key #'namestring)
  671.                )
  672.                (format t
  673.                  '#,(concatenate 'string
  674.                       "~:{~%~0@*~A~40T~3@*~7D~52T~2@*~21<" *date-format* "~>~}"
  675.                     )
  676.                  (sort pathname-list #'string< :key #'(lambda (l) (namestring (first l))))
  677.         )) ) ) )
  678.     (if (listp pathnames) (mapc #'onedir pathnames) (onedir pathnames))
  679.   )
  680.   (values)
  681. )
  682.  
  683.